home *** CD-ROM | disk | FTP | other *** search
/ Visual Basic Source Code / Visual Basic Source Code.iso / vbsource / sendun1a / clogo.cls < prev    next >
Text File  |  1999-10-15  |  8KB  |  236 lines

  1. VERSION 1.0 CLASS
  2. BEGIN
  3.   MultiUse = -1  'True
  4. END
  5. Attribute VB_Name = "cLogo"
  6. Attribute VB_GlobalNameSpace = False
  7. Attribute VB_Creatable = True
  8. Attribute VB_PredeclaredId = False
  9. Attribute VB_Exposed = False
  10. Option Explicit
  11.  
  12. Private Type RECT
  13.     Left As Long
  14.     Top As Long
  15.     Right As Long
  16.     Bottom As Long
  17. End Type
  18.  
  19. Private Declare Function FillRect Lib "user32" (ByVal hdc As Long, lpRect As RECT, ByVal hBrush As Long) As Long
  20. Private Declare Function CreateSolidBrush Lib "gdi32" (ByVal crColor As Long) As Long
  21. Private Declare Function TextOut Lib "gdi32" Alias "TextOutA" (ByVal hdc As Long, ByVal X As Long, ByVal Y As Long, ByVal lpString As String, ByVal nCount As Long) As Long
  22. Private Declare Function GetDeviceCaps Lib "gdi32" (ByVal hdc As Long, ByVal nIndex As Long) As Long
  23.  
  24. Private Const LOGPIXELSX = 88    'pixels/inch l≤gicos en X
  25. Private Const LOGPIXELSY = 90    'pixels/inch l≤gicos en Y
  26.  
  27. Private Declare Function MulDiv Lib "kernel32" (ByVal nNumber As Long, ByVal nNumerator As Long, ByVal nDenominator As Long) As Long
  28.  
  29. Private Const LF_FACESIZE = 32
  30.  
  31. Private Type LOGFONT
  32.     lfHeight As Long
  33.     lfWidth As Long
  34.     lfEscapement As Long
  35.     lfOrientation As Long
  36.     lfWeight As Long
  37.     lfItalic As Byte
  38.     lfUnderline As Byte
  39.     lfStrikeOut As Byte
  40.     lfCharSet As Byte
  41.     lfOutPrecision As Byte
  42.     lfClipPrecision As Byte
  43.     lfQuality As Byte
  44.     lfPitchAndFamily As Byte
  45.     lfFaceName(LF_FACESIZE) As Byte
  46. End Type
  47.  
  48. Private Declare Function CreateFontIndirect Lib "gdi32" Alias "CreateFontIndirectA" (lpLogFont As LOGFONT) As Long
  49. Private Declare Function SelectObject Lib "gdi32" (ByVal hdc As Long, ByVal hObject As Long) As Long
  50. Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
  51.  
  52. Private Const FW_NORMAL = 400
  53. Private Const FW_BOLD = 700
  54. Private Const FF_DONTCARE = 0
  55. Private Const DEFAULT_PITCH = 0
  56. Private Const DEFAULT_CHARSET = 1
  57.  
  58. Private Declare Function OleTranslateColor Lib "OLEPRO32.DLL" (ByVal OLE_COLOR As Long, ByVal HPALETTE As Long, pccolorref As Long) As Long
  59.  
  60. Private Const CLR_INVALID = -1
  61.  
  62. Private Declare Function SetGraphicsMode Lib "gdi32" (ByVal hdc As Long, ByVal iMode As Long) As Long
  63.  
  64. Private Const GM_ADVANCED = 2
  65.  
  66. Private Declare Function DrawText Lib "user32" Alias "DrawTextA" (ByVal hdc As Long, ByVal lpStr As String, ByVal nCount As Long, lpRect As RECT, ByVal wFormat As Long) As Long
  67. Private Declare Function lstrlen Lib "kernel32" Alias "lstrlenA" (ByVal lpString As String) As Long
  68.  
  69. 'Ctes. lfQuality:
  70. Private Const DEFAULT_QUALITY = 0           'Apariencia de la fuente es estabelcida a predeterminada
  71. Private Const DRAFT_QUALITY = 1             'Apariencia es menos importante que PROOF_QUALITY.
  72. Private Const PROOF_QUALITY = 2             'Mejor calidad de carßcter
  73. Private Const NONANTIALIASED_QUALITY = 3    'No se suavizan los bordes, aunque el sistema lo haga
  74. Private Const ANTIALIASED_QUALITY = 4       'Se suaviza si el sistema lo hace
  75.  
  76. Private m_picThis As PictureBox
  77. Private m_sCaption As String
  78. Private m_bRGBStart(1 To 3) As Integer
  79. Private m_oStartColor As OLE_COLOR
  80. Private m_bRGBEnd(1 To 3) As Integer
  81. Private m_oEndColor As OLE_COLOR
  82. Public Property Let Caption(ByVal sCaption As String)
  83.     m_sCaption = sCaption
  84. End Property
  85. Public Property Get Caption() As String
  86.     Caption = m_sCaption
  87. End Property
  88. Public Property Let DrawingObject(ByRef picThis As PictureBox)
  89.     Set m_picThis = picThis
  90. End Property
  91. Public Property Get StartColor() As OLE_COLOR
  92.     StartColor = m_oStartColor
  93. End Property
  94. Public Property Let StartColor(ByVal oColor As OLE_COLOR)
  95.     
  96.     Dim lColor As Long
  97.     
  98.     If (m_oStartColor <> oColor) Then
  99.         m_oStartColor = oColor
  100.         OleTranslateColor oColor, 0, lColor
  101.         m_bRGBStart(1) = lColor And &HFF&
  102.         m_bRGBStart(2) = ((lColor And &HFF00&) \ &H100)
  103.         m_bRGBStart(3) = ((lColor And &HFF0000) \ &H10000)
  104.         If Not (m_picThis Is Nothing) Then
  105.             Draw
  106.         End If
  107.     End If
  108.     
  109. End Property
  110. Public Property Get EndColor() As OLE_COLOR
  111.     EndColor = m_oEndColor
  112. End Property
  113. Public Property Let EndColor(ByVal oColor As OLE_COLOR)
  114.  
  115.     Dim lColor As Long
  116.     
  117.     If (m_oEndColor <> oColor) Then
  118.         m_oEndColor = oColor
  119.         OleTranslateColor oColor, 0, lColor
  120.         m_bRGBEnd(1) = lColor And &HFF&
  121.         m_bRGBEnd(2) = ((lColor And &HFF00&) \ &H100)
  122.         m_bRGBEnd(3) = ((lColor And &HFF0000) \ &H10000)
  123.         If Not (m_picThis Is Nothing) Then
  124.             Draw
  125.         End If
  126.     End If
  127. End Property
  128. Public Sub Draw()
  129.     
  130.     Dim lHeight As Long, lWidth As Long
  131.     Dim lYStep As Long
  132.     Dim lY As Long
  133.     Dim bRGB(1 To 3) As Integer
  134.     Dim tLF As LOGFONT
  135.     Dim hFnt As Long
  136.     Dim hFntOld As Long
  137.     Dim lR As Long
  138.     Dim tR As RECT
  139.     Dim rct As RECT
  140.     Dim hBr As Long
  141.     Dim hdc As Long
  142.     Dim dR(1 To 3) As Double
  143.     
  144.     On Error GoTo DrawError
  145.  
  146.     hdc = m_picThis.hdc
  147.     
  148.     lHeight = m_picThis.Height \ Screen.TwipsPerPixelY
  149.     rct.Right = m_picThis.Width \ Screen.TwipsPerPixelY
  150.     
  151.     'Establecer graduaci≤n de 255 pixeles
  152.     lYStep = lHeight \ 255
  153.     
  154.     If (lYStep = 0) Then
  155.         lYStep = 1
  156.     End If
  157.     
  158.     rct.Bottom = lHeight
  159.     
  160.     LSet tR = rct
  161.     
  162.     bRGB(1) = m_bRGBStart(1)
  163.     bRGB(2) = m_bRGBStart(2)
  164.     bRGB(3) = m_bRGBStart(3)
  165.     dR(1) = m_bRGBEnd(1) - m_bRGBStart(1)
  166.     dR(2) = m_bRGBEnd(2) - m_bRGBStart(2)
  167.     dR(3) = m_bRGBEnd(3) - m_bRGBStart(3)
  168.         
  169.     For lY = lHeight To 0 Step -lYStep
  170.         
  171.         'dibujar barra
  172.         rct.Top = rct.Bottom - lYStep
  173.         hBr = CreateSolidBrush((bRGB(3) * &H10000 + bRGB(2) * &H100& + bRGB(1)))
  174.         FillRect hdc, rct, hBr
  175.         DeleteObject hBr
  176.         rct.Bottom = rct.Top
  177.         
  178.         'ajustar color
  179.         bRGB(1) = m_bRGBStart(1) + dR(1) * (lHeight - lY) / lHeight
  180.         bRGB(2) = m_bRGBStart(2) + dR(2) * (lHeight - lY) / lHeight
  181.         bRGB(3) = m_bRGBStart(3) + dR(3) * (lHeight - lY) / lHeight
  182.         
  183.         'Debug.Print bRGB(1), (lHeight - lY) / lHeight
  184.     Next lY
  185.     
  186.     pOLEFontToLogFont m_picThis.Font, hdc, tLF
  187.     
  188.     tLF.lfEscapement = 900
  189.     hFnt = CreateFontIndirect(tLF)
  190.     If (hFnt <> 0) Then
  191.         hFntOld = SelectObject(hdc, hFnt)
  192.         lR = TextOut(hdc, 0, lHeight - 16, m_sCaption, lstrlen(m_sCaption))
  193.         SelectObject hdc, hFntOld
  194.         DeleteObject hFnt
  195.     End If
  196.     
  197.     m_picThis.Refresh
  198.     
  199.     Exit Sub
  200.     
  201. DrawError:
  202.     Debug.Print "Problema: " & Err.Description
  203. End Sub
  204. Private Sub pOLEFontToLogFont(fntThis As StdFont, hdc As Long, tLF As LOGFONT)
  205.     
  206.     Dim sFont As String
  207.     Dim iChar As Integer
  208.  
  209.     'Convertir OLE(StdFont)=>(LOGFONT) estructura
  210.     With tLF
  211.         sFont = fntThis.Name
  212.         
  213.         For iChar = 1 To Len(sFont)
  214.             .lfFaceName(iChar - 1) = CByte(Asc(Mid$(sFont, iChar, 1)))
  215.         Next iChar
  216.         
  217.         .lfHeight = -MulDiv((fntThis.Size), (GetDeviceCaps(hdc, LOGPIXELSY)), 72)
  218.         .lfItalic = fntThis.Italic
  219.         If (fntThis.Bold) Then
  220.             .lfWeight = FW_BOLD
  221.         Else
  222.             .lfWeight = FW_NORMAL
  223.         End If
  224.         
  225.         .lfUnderline = fntThis.Underline
  226.         .lfStrikeOut = fntThis.Strikethrough
  227.         .lfCharSet = fntThis.Charset
  228.         .lfQuality = ANTIALIASED_QUALITY
  229.     End With
  230.  
  231. End Sub
  232. Private Sub Class_Initialize()
  233.     StartColor = &H0
  234.     EndColor = vbButtonFace
  235. End Sub
  236.